home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / cmln0286.arc / LAST.RAT < prev    next >
Text File  |  1986-02-03  |  4KB  |  159 lines
  1. ###########LISTING 1 FOLLOWS
  2. while(<condition>)
  3.   <statement>
  4. repeat
  5.   <statement>
  6.   [until(<condition>)]
  7. for([<initialization>;[<condition>];[<increment>])
  8.   <statement>
  9. do <index>=<first>,<last>[,<increment>]
  10.   <statement>
  11. break [<n>]
  12. next [<n>]
  13. if(<condition>)
  14.   <statement>
  15. [else
  16.   <statement>]
  17. switch <variable>
  18.   {
  19.   case <constant>: <statement>
  20.   case <constant>: <statement>
  21.   ...
  22.   [default: <statement>]
  23.   }
  24. ###########LISTING 2 FOLLOWS
  25. program main #Main program
  26. logical openio
  27. CHARACTER name(10),readwr(2)
  28. integer luns(2)
  29. data luns/STDIN,STDOUT/,readwr/LETR,LETW/
  30. call remark('RATFOR Translator.')
  31. do ifile=1,2 #Open input and output files
  32.   {
  33.   do i=1,3
  34.     {
  35.     if(ifile==1)
  36.       call remark('Input file name?  .')
  37.     else
  38.       call remark('Output file name?   .')
  39.     read 1000,name; 1000 format(10a1)
  40.     if(openio(name,luns(ifile),readwr(ifile))) next 2 #Skip to next ifile if ok
  41.     }
  42.   call error('Too many tries.') #Exit if eithr LUN not opened
  43.   }
  44. call parse #Translate RATFOR program to FORTRAN object file
  45. call remark('RATFOR translation complete.')
  46. end
  47. ###########LISTING 3 FOLLOWS
  48. define(STRCHR,[ifelse($1,,,[,$1(STRLEN($2))])])
  49. define(STRSTR,[ifelse($1,,[EOS],[1h]substr($1,1,1)[,strstr(substr($1,2))])])
  50. define(STRCHR,[ifelse($1,,,[,$1(STRLEN($2))])])
  51. define(STRDAT,[ifelse($1,,,[,$1/STRSTR($2)/])])
  52. define(STRING,CHARACTER[$1(STRLEN($2))STRCHR($3,$4)STRCHER($3,$4)_
  53.   data $1/STRSTR($2)/STRDAT($3,$4)])
  54. ###########LISTING 4 FOLLOWS
  55. define(TPI,6.2831853072)
  56. subroutine fftdif(x,y,m) #Decimation in frequency FFT--reorder output
  57. #Forward transform (negative exponential)
  58. #Arguments:
  59. #  x  Real input/output array
  60. #  y  Imaginary input/output array
  61. #  m  Dimension of x and y is 2**m
  62. dimension x(1),y(1)
  63. n=2**m
  64. kjj=n
  65. do k=1,m
  66.   {
  67.   nn=kjj
  68.   kjj=kjj/2
  69.   dthet=TPI/nn
  70.   do j=1,kjj
  71.     {
  72.     thet=(j-1)*dthet
  73.     c=cos(thet)
  74.     s=sin(thet)
  75.     do i1=j,n,nn
  76.       {
  77.       j1=i1+kjj
  78.       xs=x(i1)-x(j1)
  79.       ys=y(i1)-y(j1)
  80.       x(i1)=x(i1)+x(j1)
  81.       y(i1)=y(i1)+y(j1)
  82.       x(j1)=xs*c+ys*s
  83.       y(j1)=-xs*s+ys*c
  84.       }
  85.     }
  86.   }
  87. call reordr(x,y,m)
  88. return
  89. end
  90. subroutine fftdit(x,y,m) #Decimation in time FFT--reorder input
  91. #Back transform (Positive exponential)
  92. #Arguments:
  93. #  x  Real input/output array
  94. #  y  Imaginary input/output array
  95. #  m  Dimension of x and y is 2**m
  96. dimension x(1),y(1)
  97. call reordr(x,y,m)
  98. n=2**m
  99. nn=1
  100. do k=1,m
  101.   {
  102.   kjj=nn
  103.   nn=nn+nn
  104.   dthet=TPI/nn
  105.   do j=1,kjj
  106.     {
  107.     thet=(j-1)*dthet
  108.     c=cos(thet)
  109.     s=sin(thet)
  110.     do i1=j,n,nn
  111.       {
  112.       j1=i1+kjj
  113.       xs=x(j1)*c-y(j1)*s
  114.       ys=x(j1)*s+y(j1)*c
  115.       x(j1)=x(i1)-xs
  116.       y(j1)=y(i1)-ys
  117.       x(i1)=x(i1)+xs
  118.       y(i1)=y(i1)+ys
  119.       }
  120.     }
  121.   }
  122. return
  123. end
  124. subroutine reordr(x,y,m) #Reorders data for FFT input or output
  125. #Arguments:
  126. #  x  Real input/output array
  127. #  y  Imaginary input/output array
  128. #  m  Dimension of x and y is 2**m
  129. dimension x(1),y(1)
  130. n=2**m
  131. do i=1,n
  132.   {
  133.   k=i-1 #Reverse-bit k to form j-1
  134.   j=1
  135.   ib=n
  136.   do l=1,m #Add bits to j-1 from top down where bits exist in k from bottom up
  137.     {
  138.     ib=ib/2
  139.     kn=k/2
  140.     j=j+(k-kn*2)*ib
  141.     k=kn
  142.     }
  143.   if(j>i) #Interchange and conjugate array elements if j>i
  144.     {
  145.     q=x(j)
  146.     x(j)=x(i)
  147.     x(i)=q
  148.     q=y(j)
  149.     y(j)=-y(i)
  150.     y(i)=-q
  151.     }
  152.   else if(i==j) #Conjugate only if j==i
  153.     y(i)=-y(i)
  154.   } #No action if j<i; elements already reordered
  155. return
  156. end
  157. 
  158.   else if(i==j) #Conjugate only if j==i
  159.     y(i